(*
  Copyright (c) 2009 Barry Schwartz

  Permission is hereby granted, free of charge, to any person
  obtaining a copy of this software and associated documentation
  files (the "Software"), to deal in the Software without
  restriction, including without limitation the rights to use,
  copy, modify, merge, publish, distribute, sublicense, and/or sell
  copies of the Software, and to permit persons to whom the
  Software is furnished to do so, subject to the following
  conditions:

  The above copyright notice and this permission notice shall be
  included in all copies or substantial portions of the Software.

  THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
  EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES
  OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
  NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
  HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
  WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
  FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR
  OTHER DEALINGS IN THE SOFTWARE.
*)

(*-----------------------------------------------------------------------*)

open FontForge
open Dim
open Logging
open OpenType
open UniTools
open XNum
module IntMap = Map.Make(OrderedInt)

(*-----------------------------------------------------------------------*)

(* glyph descriptions *)

type glyph_desc =
  | Undef
  | Simple of int
  | Raised of int * num
  | Accent of int * int
  | Sequence of int list
  | Extendable of glyph_desc * glyph_desc * glyph_desc * glyph_desc
  (* with sexp_of *)

let dump_glyph_desc ?font gd =
  begin
    log_string "(glyph_desc ";
    begin
      match gd with
        | Undef -> log_string "Undef"
        | Simple n ->
            begin
              log_string "Simple ";
              log_int n;
              match font with
                | Some f ->
                    begin
                      try
                        let glyphs = FFfont.glyphs f in
                          log_string (" " ^ FFglyph.glyph_str glyphs.(n))
                      with _ -> ()
                    end
                | None -> ()
            end
        | Raised (n, d) ->
            begin
              log_string "Raised ";
              log_int n;
              begin
                match font with
                  | Some f ->
                      begin
                        try
                          let glyphs = FFfont.glyphs f in
                            log_string (" " ^ FFglyph.glyph_str glyphs.(n))
                        with _ -> ()
                      end
                  | None -> ()
              end;
              log_string " ";
              log_num d;
            end
        | Accent (n, m) ->
            log_string "Accent ";
            log_int n;
            log_string " ";
            log_int m;
        | Sequence _ -> log_string "Sequence"
        | Extendable (_, _, _, _) -> log_string "Extendable"
    end;
    log_string ") "
  end

(*-----------------------------------------------------------------------*)

module OrderedGlyphDesc =
struct
  type t = glyph_desc
  let compare : glyph_desc -> glyph_desc -> int = compare    
end
  
module GlyphMap  = Map.Make(OrderedGlyphDesc)
module GlyphSet  = Set.Make(OrderedGlyphDesc)
module GlyphTrie = DynamicTrie.Make(OrderedGlyphDesc)

type glyph_text =
  | NoGlyphText
  | GlyphText of UniText.t
  | ClusterContinuation
  (* with sexp_of *)

type ('font, 'box, 'cmd) glyph_item =
    [
    | `Glyph of glyph_desc * 'font * glyph_text
    | `Kern of num * num
    | `Box of 'box
    | `Command of 'cmd
    | `Break of
        num * bool *
          ('font, 'box, 'cmd) glyph_item array *
          ('font, 'box, 'cmd) glyph_item array *
          ('font, 'box, 'cmd) glyph_item array
    ]
 (* with sexp_of *)

let dump_glyph_item ?font gi =
  log_string "(glyph_item ";
  begin
    match gi with
      | `Glyph (gd, _, text) ->
          log_string "`Glyph ";
          dump_glyph_desc ?font gd;
          begin
            match text with
              | NoGlyphText -> ()
              | GlyphText u -> log_uniText u
              | ClusterContinuation -> log_string "_"
          end
      | `Kern (n, m) ->
          log_string "`Kern ";
          log_num n;
          log_string " ";
          log_num m
      | `Box _ -> log_string "`Box"
      | `Command _ -> log_string "`Command"
      | `Break _ -> log_string "`Break"
  end;
  log_string ")\n"

(*-----------------------------------------------------------------------*)
    
type ('font, 'box, 'cmd) glyph_composer =
    ('font, 'box, 'cmd) glyph_item list -> ('font, 'box, 'cmd) glyph_item list
(* with sexp_of *)

(*-----------------------------------------------------------------------*)

let dump_glyph_text t =
  match t with
    | NoGlyphText -> log_string "<NoGlyphText>"
    | GlyphText u ->
        log_string "<GlyphText \"";
        log_uc_string (UniText.ints_of u);
        log_string "\">"
    | ClusterContinuation -> log_string "<ClusterContinuation>"

let combine_glyph_texts t1 t2 =
  match t1 with 
    | NoGlyphText ->
        begin
          match t2 with
            | GlyphText _ ->
                t2
            | NoGlyphText | ClusterContinuation ->
                NoGlyphText
        end
    | GlyphText u ->
        begin
          match t2 with
            | GlyphText v ->
                GlyphText (UniText.append u v)
            | NoGlyphText | ClusterContinuation ->
                t1
        end
    | ClusterContinuation ->
        begin
          match t2 with
            | GlyphText _ ->            (* This is an awkward case. *)
                t2
            | NoGlyphText | ClusterContinuation ->
                ClusterContinuation
        end

(*-----------------------------------------------------------------------*)

(* auxiliary functions *)

let get_break_penalty break =
  match break with
    | `Break (penalty, _, _, _, _) -> penalty
    |  _    -> invalid_arg "Expected `Break"

let break_is_hyph break =
  match break with
    | `Break (_, hyph, _, _, _) -> hyph
    |  _    -> invalid_arg "Expected `Break"

let get_pre_break break =
  match break with
    | `Break (_, _, pre, _, _) -> pre
    |  _    -> invalid_arg "Expected `Break"

let get_post_break break =
  match break with
    | `Break (_, _, _, post, _) -> post
    |  _    -> invalid_arg "Expected `Break"

let get_no_break break =
  match break with
    | `Break (_, _, _, _, no) -> no
    |  _    -> invalid_arg "Expected `Break"

let is_break item =
  match item with
    | `Break _ -> true
    | _ -> false

let is_nonhyph_break item =
  match item with
    | `Break _ as b -> not (break_is_hyph b)
    | _ -> false

(*************************************************************************)

let parse_script_and_lang uni_s =
  let s = UniText.to_string ~encoding:"ISO-8859-1" uni_s in
  let re = Str.regexp "\\(.*\\)-\\(.*\\)" in
  let does_match = Str.string_match re s 0 in
  let (script, lang) =
    if does_match then
      (Str.matched_group 1 s, Str.matched_group 2 s)
    else
      (s, "dflt")
  in
  let script_length = min 4 (String.length script) in
  let lang_length = min 4 (String.length lang) in
  let script_4 = String.make 4 ' ' in
  let lang_4 = String.make 4 ' ' in
    for i = 0 to script_length - 1 do
      script_4.[i] <- script.[i]
    done;
    for i = 0 to lang_length - 1 do
      lang_4.[i] <- lang.[i]
    done;
    (OpenType.Tag.make script_4, OpenType.Tag.make lang_4)


let group_items items =

  let rec collect_glyphs result remainder =
    match remainder with
      | [] -> (List.rev result, [])
      | `Glyph _ as g :: t -> collect_glyphs (g :: result) t
      | what_is_left -> (List.rev result, what_is_left)
  in
  let rec collect_non_glyphs result remainder =
    match remainder with
      | [] -> (List.rev result, [])
      | `Glyph _ :: _ -> (List.rev result, remainder)
      | ng :: t -> collect_non_glyphs (ng :: result) t
  in
  let rec group_them result remaining_items =
    match remaining_items with
      | [] -> List.rev result
      | `Glyph _ :: _ ->
          let (glyphs, more_items) = collect_glyphs [] remaining_items in
          let new_result = glyphs :: result in
            group_them new_result more_items
      | `Kern _ :: _
      | `Box _ :: _
      | `Command _ :: _
      | `Break _ :: _ ->
          let (non_glyphs, more_items) = collect_non_glyphs [] remaining_items in
          let new_result = non_glyphs :: result in
            group_them new_result more_items
  in
    group_them [] items


let rec adjustments_to_kerns reversed_result glyphs_and_adjustments =
  match glyphs_and_adjustments with
    | [] -> reversed_result
    | (glyph, (x_placement, y_placement, x_advance, y_advance)) :: t ->
        let result1 =
          if x_placement = 0 then
            reversed_result
          else
            `Kern ((num_of_int x_placement), num_zero) :: reversed_result
        in
        let result2 =
          if y_placement = 0 then
            glyph :: result1
          else
            begin
              match glyph with
                | `Glyph (Simple i, f, text) ->
                    let g = `Glyph (Raised (i, num_of_int y_placement), f, text) in
                      g :: result1
                | _ -> assert false
            end 
        in
        let result3 =
          if x_advance - x_placement = 0 && y_advance - y_placement = 0 then
            result2
          else
            `Kern (num_of_int (x_advance - x_placement),
                   num_of_int (y_advance - y_placement)) :: result2
        in
          adjustments_to_kerns result3 t


let rec combine_kerns reversed_result items =
  match items with
    | [] -> reversed_result
    | `Kern (x, y) :: `Kern (u, v) :: t ->
        combine_kerns (`Kern (add_num x u, add_num y v) :: reversed_result) t
    | _ as g :: t -> combine_kerns (g :: reversed_result) t

(*-----------------------------------------------------------------------*)

let ot_composer scale get_gsub_marker get_gpos_marker =

  let single_substitution substitutions ga i =
    match ga.(i) with
      | (`Glyph (Simple i_gid, f, text), p) ->
          ga.(i) <- (`Glyph (Simple (GID.to_int (GIDMap.find (GID.of_int i_gid) substitutions)), f, text), p);
          (ga, i + 1)
      | _ -> raise Not_found
  in

  let rec components_match components ga i =
    match components with
      | [] -> true
      | gid :: more_components ->
          if i = Array.length ga then
            false
          else
            match ga.(i) with
              | (`Glyph (Simple i_gid, _, _), _) ->
                  gid = GID.of_int i_gid && components_match more_components ga (i + 1)
              | _ -> false
  in
  let ligature_substitution ligatures ga i =
    match ga.(i) with
      | (`Glyph (Simple i_gid, f, text), p) ->
          let rec substitution ligs =
            match ligs with
              | [] -> raise Not_found
              | (components, new_gid) :: tail ->
                  if components_match components ga (i + 1) then
                    let component_count = List.length components in
                      begin
                        let get_glyph_text glyph =
                          match glyph with
                            | (`Glyph (_, _, t), _) -> t
                            | _ -> assert false
                        in
                        let rec combine_texts k =
                          let t = get_glyph_text ga.(i + k) in
                            if k = component_count then
                              t
                            else
                              combine_glyph_texts t (combine_texts (k + 1))
                        in
                        let combined_text = combine_glyph_texts text (combine_texts 1) in
                        let g = (`Glyph (Simple (GID.to_int new_gid), f, combined_text), p) in
                          ga.(i) <- g;
                          let ga_length = Array.length ga in
                          let ga_left = Array.sub ga 0 (i + 1) in
                          let ga_right = (Array.sub ga (i + component_count + 1)
                                            (ga_length - (i + 1) - component_count)) in
                            (Array.append ga_left ga_right, i + 1)
                      end
                  else
                    substitution tail
          in
            substitution (GIDMap.find (GID.of_int i_gid) ligatures)
      | _ -> raise Not_found
  in

  let rec do_subst_lookup_subtables ga i subtables =
    match subtables with
      | [] -> ga
      | subtab :: more_subtables ->
          let (ga1, _) =
            match subtab with
              | SingleSubstitutionSubtable substitutions -> single_substitution substitutions ga i
              | LigatureSubstitutionSubtable ligatures -> ligature_substitution ligatures ga i
              | _ -> failwith "Substitute.do_subst_lookup_subtables"
          in
            do_subst_lookup_subtables ga1 i more_subtables
  in

  let rec do_subst_lookups subst_lookups ga i =
    match subst_lookups with
      | [] -> ga
      | (seq_index, lookup) :: t ->
          let ga1 = do_subst_lookup_subtables ga (i + seq_index) lookup.subTables in
            do_subst_lookups t ga1 i
  in

  let rec check_coverage direction coverage ga i =
    match coverage with
      | [] -> ()
      | coverage_set :: t ->
          try
            match ga.(i) with
              | (`Glyph (Simple i_gid, _, _), _) ->
                  if GIDSet.mem (GID.of_int i_gid) coverage_set then
                    check_coverage direction t ga (i + direction)
                  else
                    raise Not_found
              | _ ->
                  raise Not_found

          with Invalid_argument "index out of bounds" -> raise Not_found
  in
  let chaining_context_substitution gsub_lookups chain_coverage ga i =
    let p = chain_coverage in
    let input_length = List.length p.input_coverage in
      check_coverage (-1) p.backtrack_coverage ga (i - 1);
      check_coverage 1 p.input_coverage ga i;
      check_coverage 1 p.lookahead_coverage ga (i + input_length);
      let total_length_beforehand = Array.length ga in
      let lookups = List.map (fun (seq_index, i) -> (seq_index, gsub_lookups.(i))) p.lookup_indexes in
      let ga1 = do_subst_lookups lookups ga i in
      let total_length_afterwards = Array.length ga1 in
        (ga1, i + input_length + (total_length_afterwards - total_length_beforehand))
  in

  let single_adjustment adjustments ga i =
    match ga.(i) with
      | (`Glyph (Simple i_gid, f, text), (x_placement, y_placement, x_advance, y_advance)) ->
          let adj = GIDMap.find (GID.of_int i_gid) adjustments in
            ga.(i) <- (`Glyph (Simple i_gid, f, text),
                       (x_placement + adj.x_placement_adj, y_placement + adj.y_placement_adj,
                        x_advance + adj.x_advance_adj, y_advance + adj.y_advance_adj));
            (ga, i + 1)

      | _ -> raise Not_found
  in

  let pair_adjustment finder adjustments ga i =
    if i + 1 = Array.length ga then
      raise Not_found
    else
      match (ga.(i), ga.(i + 1)) with
        | ((`Glyph (Simple i_gid, f, text), (x_placement, y_placement, x_advance, y_advance)),
           (`Glyph (Simple i1_gid, f1, text1), (x1_placement, y1_placement, x1_advance, y1_advance))) ->
            let (adj, adj1) = finder adjustments i_gid i1_gid in
              begin
                match adj with
                  | None -> ()
                  | Some p ->
                      ga.(i) <- (`Glyph (Simple i_gid, f, text),
                                 (x_placement + p.x_placement_adj, y_placement + p.y_placement_adj,
                                  x_advance + p.x_advance_adj, y_advance + p.y_advance_adj))
              end;
              begin
                match adj1 with
                  | None -> ()
                  | Some p ->
                      ga.(i + 1) <- (`Glyph (Simple i1_gid, f1, text1),
                                     (x1_placement + p.x_placement_adj, y1_placement + p.y_placement_adj,
                                      x1_advance + p.x_advance_adj, y1_advance + p.y_advance_adj))
              end;
              if adj1 = None then (ga, i + 1) else (ga, i + 2)

        | _ -> raise Not_found
  in
  let find_simple_pair_adjustment adjustments i_gid i1_gid =
    GIDMap.find (GID.of_int i1_gid) (GIDMap.find (GID.of_int i_gid) adjustments)
  in
  let find_class_based_kerning adjustments i_gid i1_gid =
    let (row_size, firsts, seconds, adj) = adjustments in
    let i = GIDMap.find (GID.of_int i_gid) firsts in
    let j = GIDMap.find (GID.of_int i1_gid) seconds in
      (Some { x_placement_adj = 0;
              y_placement_adj = 0;
              x_advance_adj   = adj.((row_size * i) + j);
              y_advance_adj   = 0 },
       None)
  in
  let try_one_subtable gsub_lookups _gpos_lookups subtable ga i =
    match subtable with
      | SingleSubstitutionSubtable substitutions ->
          single_substitution substitutions ga i
      | LigatureSubstitutionSubtable ligatures ->
          ligature_substitution ligatures ga i
      | ChainingContextSubstitution3Subtable chain_coverage ->
          chaining_context_substitution gsub_lookups chain_coverage ga i
      | SingleAdjustmentSubtable adjustments ->
          single_adjustment adjustments ga i
      | PairAdjustmentSubtable adjustments ->
          pair_adjustment find_simple_pair_adjustment adjustments ga i
      | ClassBasedKerningSubtable adjustments ->
          pair_adjustment find_class_based_kerning adjustments ga i
  in
  let rec try_subtables gsub_lookups gpos_lookups subtables ga i =
    match subtables with
      | [] -> (ga, i + 1)
      | h :: t ->
          try
            try_one_subtable gsub_lookups gpos_lookups h ga i
          with
            | Not_found -> try_subtables gsub_lookups gpos_lookups t ga i
  in
  let rec do_one_lookup gsub_lookups gpos_lookups lookup ga i =
    if i = Array.length ga then
      ga
    else
      let (ga1, i1) = try_subtables gsub_lookups gpos_lookups lookup.subTables ga i in
        do_one_lookup gsub_lookups gpos_lookups lookup ga1 i1
  in
  let do_lookups gsub_lookups gpos_lookups lookups_to_do glyphs_and_adjustments =
    let ga = Array.of_list glyphs_and_adjustments in
    let ga_adjusted =
      List.fold_left
        (fun ga_entry lookup -> do_one_lookup gsub_lookups gpos_lookups lookup ga_entry 0)
        ga lookups_to_do
    in
      Array.to_list ga_adjusted
  in
  let scale_displacements items =
    List.map
      (fun item ->
         match item with
           | `Glyph (Raised (g, d), f, text) -> `Glyph (Raised (g, mult_num scale d), f, text)
           | `Kern (x, y) -> `Kern (mult_num scale x, mult_num scale y)
           | _ -> item)
      items
  in
    begin
      fun _font script feature_set items ->

        (*
        List.iter dump_glyph_item items;
        log_string "----------------------------------------------------------\n";
        *)

        let (script, lang) = parse_script_and_lang script in

        let gsub_marker = get_gsub_marker script lang in
        let gsub_lookups = LookupMarker.lookups gsub_marker in
        let gsub_lookup_indexes = LookupMarks.indexes (FeatureSet.marks feature_set gsub_marker) in
        let gsub_lookups_to_do = List.map (fun i -> gsub_lookups.(i)) gsub_lookup_indexes in

        let gpos_marker = get_gpos_marker script lang in
        let gpos_lookups = LookupMarker.lookups gpos_marker in
        let gpos_lookup_indexes = LookupMarks.indexes (FeatureSet.marks feature_set gpos_marker) in
        let gpos_lookups_to_do = List.map (fun i -> gpos_lookups.(i)) gpos_lookup_indexes in

        let lookups_to_do = gsub_lookups_to_do @ gpos_lookups_to_do in
        let list_of_lists = group_items items in

        let rec build_changes result grouped_items =
          begin
            match grouped_items with
              | [] -> result

              | (`Glyph _ :: _) as glyphs :: t ->
                  let glyphs_and_adjustments = List.map (fun g -> (g, (0, 0, 0, 0))) glyphs in
                  let adjusted_glyphs = do_lookups gsub_lookups gpos_lookups lookups_to_do glyphs_and_adjustments in
                  let glyphs_and_kerns = adjustments_to_kerns [] adjusted_glyphs in
                  let glyphs_and_combined_kerns = combine_kerns [] glyphs_and_kerns in
                  let new_items = scale_displacements glyphs_and_combined_kerns in
                    build_changes (result @ new_items) t

              | h :: t -> build_changes (result @ h) t
          end
        in
          build_changes [] list_of_lists
    end

(*-----------------------------------------------------------------------*)
